home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 25 / Cream of the Crop 25.iso / program / fpk65_66.zip / SOURCE / RTL / DOS / TEXT.PPI < prev    next >
Text File  |  1997-02-02  |  15KB  |  445 lines
  1. {***************************************************************************}
  2. {                               Textausgabe                                 }
  3. {***************************************************************************}
  4.  
  5.     const
  6.        { maximal 16 Vektorfonts unterstützen }
  7.        { um mehr Fonts laden zu können, muß  }
  8.        { diese Variable erhöht werden        }
  9.        maxfonts = 16;
  10.        fontdivs:array[0..maxfonts]of integer=
  11.        (1,4,3,4,4,4,4,4,4,3,3,1,1,1,1,1,1);
  12.     
  13.     type
  14.        pbyte = ^byte;
  15.  
  16.     {$PACKRECORDS 1}
  17.        pfontdata = ^tfontdata;
  18.  
  19.        tfontdata = record
  20.           filetyp              : char;
  21.           nr_chars             : word;
  22.           undefined1           : byte;
  23.           value_first_char     : byte;
  24.           undefined2           : array[1..3] of byte;
  25.           dist_origin_top      : shortint;
  26.           dist_origin_baseline : shortint;
  27.           dist_origin_bottom   : shortint;
  28.           undefined3           : array[1..5] of byte;
  29.        end;
  30.  
  31.     {$PACKRECORDS NORMAL}
  32.  
  33.        tfontrec = record
  34.           name : string[8];
  35.           data : pointer;
  36.           header : pfontdata;
  37.           offsets : pword;
  38.           widths : pbyte;
  39.           instr : pbyte;
  40.        end;
  41.  
  42.     var
  43.        fonts : array[1..maxfonts] of tfontrec;
  44.        installedfonts : longint;
  45.  
  46. {$I FONT.PPI}              
  47.  
  48.     { gibt true zurück, wenn p auf eine gültige Fontdatei zeigt }
  49.  
  50.     function testfont(p : pointer) : boolean;
  51.  
  52.       begin
  53.          testfont:=(pchar(p)^='P') and
  54.           (pchar(p+1)^='K') and
  55.           (pchar(p+2)^=#8) and
  56.           (pchar(p+3)^=#8);
  57.       end;
  58.  
  59.     { setzt die Hilfsdaten für den Font mit der Nr. font }
  60.     { der Zeiger data muß schon gesetzt sein             }
  61.  
  62.     function setupfont(font : word) : integer;
  63.  
  64.       begin
  65.          setupfont:=grOK;
  66.          fonts[font].header:=fonts[font].data+$80;
  67.          if fonts[font].header^.filetyp<>'+' then
  68.            begin
  69.               setupfont:=grInvalidFont;
  70.               exit;
  71.            end;
  72.          fonts[font].offsets:=fonts[font].data+$90;
  73.          fonts[font].widths:=pbyte(fonts[font].offsets+fonts[font].header^.nr_chars*2);
  74.          fonts[font].instr:=fonts[font].widths+fonts[font].header^.nr_chars;
  75.       end;
  76.  
  77.     function InstallUserFont(const FontFileName : string) : integer;
  78.  
  79.       begin
  80.          _graphresult:=grOk;
  81.          { es muß kein Graphikmodus gesetzt sein! }
  82.          { ist noch Platz für einen Font ? }
  83.          if installedfonts=maxfonts then
  84.            begin
  85.               _graphresult:=grError;
  86.               exit;
  87.            end;
  88.          inc(installedfonts);
  89.          fonts[installedfonts].name:=FontFileName;
  90.          fonts[installedfonts].data:=nil;
  91.          InstallUserFont:=installedfonts;
  92.       end;
  93.  
  94.     function RegisterBGIfont(font : pointer) : integer;
  95.  
  96.       var
  97.          hp : pbyte;
  98.          b : word;
  99.          name : string[12];
  100.  
  101.       begin
  102.          { noch nicht garantiert, daß alles klappt }
  103.          RegisterBGIfont:=grInvalidFontNum;
  104.          { es muß kein Graphikmodus gesetzt sein! }
  105.          if testfont(font) then
  106.            begin
  107.               hp:=pbyte(font);
  108.               { Ende des Textheaders suchen }
  109.               while hp^<>$1a do
  110.                 hp:=hp+1;
  111.               { auf Start des Names springen }
  112.               hp:=hp+3;
  113.               { Namen lesen }
  114.               name:='';
  115.               for b:=0 to 3 do
  116.                 name:=name+char((hp+b)^);
  117.               { richtigen Font suchen }
  118.               for b:=1 to installedfonts do
  119.                 begin
  120.                    if fonts[b].name=name then
  121.                      begin
  122.                         fonts[b].data:=font;
  123.                         RegisterBGIfont:=grOK;
  124.                         RegisterBGIfont:=setupfont(b);
  125.                      end;
  126.                 end;
  127.            end
  128.          else
  129.            RegisterBGIFont:=grInvalidFont;
  130.       end;
  131.  
  132.     procedure GetTextSettings(var TextInfo : TextSettingsType);
  133.  
  134.       begin
  135.          _graphresult:=grOk;
  136.          if not isgraphmode then
  137.            begin
  138.               _graphresult:=grnoinitgraph;
  139.               exit;
  140.            end;
  141.          textinfo:=akttextinfo;
  142.       end;
  143.  
  144.     procedure OutText(const TextString : string);
  145.       var x,y:integer;
  146.       begin
  147.          _graphresult:=grOk;
  148.          if not isgraphmode then
  149.            begin
  150.               _graphresult:=grnoinitgraph;
  151.               exit;
  152.            end;
  153.          x:=curx; y:=cury;
  154.          OutTextXY(curx,cury,TextString);
  155.          { wenn horizontal und linksbündig ausgegeben wird, dann }
  156.          { Grafikcursor nachführen }
  157.          if (akttextinfo.direction=HorizDir) and
  158.            (akttextinfo.horiz=LeftText) then
  159.                inc(x,textwidth(TextString));
  160.          curx:=x; cury:=y;   { LineTo manipuliert den GrafikCursor !! }
  161.       end;
  162.  
  163.     procedure outtext(const charakter : char);
  164.     var s:string;
  165.         x,y:integer;
  166.     begin
  167.       s:=charakter;
  168.       _graphresult:=grOk;
  169.          if not isgraphmode then
  170.            begin
  171.               _graphresult:=grnoinitgraph;
  172.               exit;
  173.            end;
  174.          x:=curx; y:=cury;
  175.          OutTextXY(curx,cury,s);
  176.          { wenn horizontal und linksbündig ausgegeben wird, dann }
  177.          { Grafikcursor nachführen }
  178.          { if (akttextinfo.direction=HorizDir) and
  179.            (akttextinfo.horiz=LeftText) then }
  180.                inc(x,textwidth(s));  
  181.          curx:=x; cury:=y;   { LineTo manipuliert den GrafikCursor !! }
  182.     end;
  183.    
  184.     procedure OutTextXY(x,y : integer;const TextString : string);
  185.  
  186.       var
  187.          b1,b2         : shortint;
  188.          c,instr,mask  : byte;
  189.          i,j,k         : longint;
  190.          oldvalues     : linesettingstype;
  191.          nextpos       : word;
  192.          xpos,ypos,offs: longint;        
  193.          FontPtr       : Pointer;
  194.       begin
  195.          _graphresult:=grOk;
  196.          if not isgraphmode then
  197.            begin
  198.               _graphresult:=grnoinitgraph;
  199.               exit;
  200.            end;
  201.  
  202.          { wirkliche x- und y-Startposition berechnen }
  203.          if akttextinfo.direction=horizdir then
  204.          begin   
  205.            case akttextinfo.horiz of
  206.                 centertext : XPos:=(textwidth(textstring) shr 1);
  207.                 lefttext   : XPos:=0;
  208.                 righttext  : XPos:=textwidth(textstring);
  209.            end;
  210.            case akttextinfo.vert of
  211.                centertext : YPos:=(textheight(textstring) shr 1);
  212.                bottomtext : YPos:=0;
  213.                toptext    : YPos:=textheight(textstring);
  214.            end;
  215.          end else  
  216.          begin   
  217.            case akttextinfo.horiz of
  218.                 centertext : XPos:=(textheight(textstring) shr 1);
  219.                 lefttext   : XPos:=0;
  220.                 righttext  : XPos:=textheight(textstring);
  221.            end;
  222.            case akttextinfo.vert of
  223.                centertext : YPos:=(textwidth(textstring) shr 1);
  224.                bottomtext : YPos:=0;
  225.                toptext    : YPos:=textwidth(textstring);
  226.            end;     
  227.          end;         
  228.          X:=X-XPos; Y:=Y+YPos;
  229.          XPos:=X; YPos:=Y;
  230.          
  231.          if akttextinfo.font=DefaultFont then begin
  232.            y:=y-6;     
  233.            c:=textwidth(textstring) div 8 - 1; { Charcounter }
  234.            FontPtr:=@defaultfontdata;                
  235.            for i:=0 to c do begin 
  236.              offs:=ord(textString[i+1]) shl 3;   { Offset des Chars in Data }
  237.              for j:=0 to 7 do begin
  238.                mask:=$80;
  239.                b1:=defaultfontdata[offs+j];    { Offset der Charzeile }      
  240.                xpos:=i shl 3+x;
  241.                for k:=0 to 7 do begin
  242.                  if (b1 and mask) <> 0 then putpixel(xpos+k,j+y,aktcolor);
  243.                  mask:=mask shr 1;
  244.                end;
  245.              end;
  246.            end;        
  247.          end else
  248.            
  249.            begin
  250.               { Linienstil setzen }
  251.               getlinesettings(oldvalues);
  252.               setlinestyle(solidln,oldvalues.pattern,normwidth);
  253.               if akttextinfo.direction=vertdir then xpos:=xpos + Textheight(textstring);
  254.               curx:=xpos; cury:=ypos; x:=xpos; y:=ypos;
  255.               for i:=1 to length(textstring) do
  256.                 begin
  257.                    c:=byte(textstring[i]);
  258.                    c:=c-fonts[akttextinfo.font].header^.value_first_char;
  259.                    { definiertes Zeichen ? }
  260.                    if (c<0) or (c>=fonts[akttextinfo.font].header^.nr_chars) then continue;
  261.                    nextpos:=fonts[akttextinfo.font].offsets[c];
  262.                    while true do
  263.                      begin
  264.                          b1:=fonts[akttextinfo.font].instr[nextpos];
  265.                          nextpos:=nextpos+1;
  266.                          b2:=fonts[akttextinfo.font].instr[nextpos];
  267.                          nextpos:=nextpos+1;
  268.                          instr:=((b1 and $80) shr 6)+((b2 and $80) shr 7);
  269.                          b1:=b1 and $7f;
  270.                          b2:=b2 and $7f;
  271.                          { Vorzeichen erweitern }
  272.                          if (b1 and $40)<>0 then b1:=b1 or $80;
  273.                          if (b2 and $40)<>0 then b2:=b2 or $80;
  274.                          { neue Stiftposition berechnen und skalieren }
  275.                          if akttextinfo.direction=VertDir then
  276.                            begin
  277.                              xpos:=x-((b2*aktmultx) div aktdivx);
  278.                              ypos:=y-((b1*aktmulty) div aktdivy); 
  279.                            end
  280.                          else
  281.                            begin
  282.                              xpos:=x+((b1*aktmultx) div aktdivx) ;
  283.                              ypos:=y-((b2*aktmulty) div aktdivy) ; 
  284.                            end;
  285.                          case instr of
  286.                             0 : break;
  287.                             2 : begin curx:=xpos; cury:=ypos; end;
  288.                             3 : begin line(curx,cury,xpos,ypos);
  289.                                       curx:=xpos; cury:=ypos;
  290.                                 end;
  291.                          end;
  292.                      end;
  293.                    if akttextinfo.direction=VertDir then
  294.                      y:=y-(fonts[akttextinfo.font].widths[c]*aktmultx div aktdivx)              
  295.                    else
  296.                      x:=x+(fonts[akttextinfo.font].widths[c]*aktmultx div aktdivx) ; 
  297.                 end;  
  298.               setlinestyle( oldvalues.linestyle, oldvalues.pattern, oldvalues.thickness);
  299.            end;
  300.       end;
  301.  
  302.     procedure outtextxy(x,y: Integer;const charakter : char);
  303.     var s:string;
  304.     begin
  305.       s:=charakter;
  306.       outtextXY(x,y,s);
  307.     end;
  308.    
  309.     function TextHeight(const TextString : string) : word;
  310.  
  311.       begin
  312.          _graphresult:=grOk;
  313.          if not isgraphmode then
  314.            begin
  315.               _graphresult:=grnoinitgraph;
  316.               exit;
  317.            end;
  318.          if akttextinfo.font=DefaultFont 
  319.             then TextHeight:=6+akttextinfo.charsize
  320.             else
  321.               TextHeight:=(((fonts[akttextinfo.font].header^.dist_origin_top-
  322.                 fonts[akttextinfo.font].header^.dist_origin_bottom) * aktmulty) div aktdivy) ;
  323.       end;
  324.  
  325.     function TextWidth(const TextString : string) : word;
  326.       var i,x : Integer;
  327.           c   : byte;
  328.       begin
  329.          _graphresult:=grOk;  x:=0;
  330.          if not isgraphmode then
  331.            begin
  332.               _graphresult:=grnoinitgraph;
  333.               exit;
  334.            end;
  335.          if akttextinfo.font = Defaultfont then
  336.             TextWidth:=length(TextString)*8*akttextinfo.charsize
  337.             else begin
  338.                for i:=1 to length(TextString) do begin
  339.                    c:=byte(textstring[i]);
  340.                    dec(c,fonts[akttextinfo.font].header^.value_first_char);
  341.                    { definiertes Zeichen ? }
  342.                    if (c<0) or (c>=fonts[akttextinfo.font].header^.nr_chars) then
  343.                      continue;
  344.                    x:=x+fonts[akttextinfo.font].widths[c];                  
  345.                end;
  346.             TextWidth:=((x * aktmultx) div aktdivx) ;
  347.             end;
  348.       end;
  349.  
  350.     procedure SetTextJustify(horiz,vert : word);
  351.  
  352.       begin
  353.          _graphresult:=grOk;
  354.          if not isgraphmode then
  355.            begin
  356.               _graphresult:=grnoinitgraph;
  357.               exit;
  358.            end;
  359.          if (horiz<0) or (horiz>2) or
  360.             (vert<0) or (vert>2) then
  361.            begin
  362.               _graphresult:=grError;
  363.               exit;
  364.            end;
  365.          akttextinfo.horiz:=horiz;
  366.          akttextinfo.vert:=vert;
  367.       end;
  368.  
  369.     procedure SetTextStyle(font,direction : word;charsize : word);
  370.  
  371.       var
  372.          f : file;
  373.  
  374.       begin
  375.          _graphresult:=grOk;
  376.          if not isgraphmode then
  377.            begin
  378.               _graphresult:=grnoinitgraph;
  379.               exit;
  380.            end;
  381.          { Parameter auf Gültigkeit überprüfen }
  382.          if font>installedfonts then
  383.            begin
  384.               _graphresult:=grInvalidFontNum;
  385.               exit;
  386.            end;
  387.          akttextinfo.font:=font;
  388.          if (direction<>HorizDir) and (direction<>VertDir) then
  389.            direction:=HorizDir;
  390.          akttextinfo.direction:=direction;
  391.          akttextinfo.charsize:=charsize;
  392.          if (charsize <> usercharsize) then begin        
  393.             aktmultx:=charsize;
  394.             aktdivx:=fontdivs[font];
  395.             aktmulty:=charsize;
  396.             aktdivy:=fontdivs[font];
  397.          end;
  398.          { Fontdatei laden ? }
  399.          if (font>0) and not assigned(fonts[font].data) then
  400.            begin
  401.               assign(f,bgipath+fonts[font].name+'.CHR');
  402.               reset(f,1);
  403.               if ioresult<>0 then
  404.                 begin
  405.                    _graphresult:=grFontNotFound;
  406.                    akttextinfo.font:=DefaultFont;
  407.                    exit;
  408.                 end;
  409.               getmem(fonts[font].data,filesize(f));
  410.               if not assigned(fonts[font].data) then
  411.                 begin
  412.                    _graphresult:=grNoFontMem;
  413.                    akttextinfo.font:=DefaultFont;
  414.                    exit;
  415.                 end;
  416.               blockread(f,fonts[font].data^,filesize(f));
  417.  
  418.               if testfont(fonts[font].data) then
  419.                 _graphresult:=setupfont(font)
  420.               else
  421.                 begin
  422.                    _graphresult:=grInvalidFont;
  423.                    akttextinfo.font:=DefaultFont;
  424.                    freemem(fonts[font].data,filesize(f));
  425.                 end;
  426.               close(f);
  427.            end;
  428.       end;
  429.  
  430.     procedure SetUserCharSize(Multx,Divx,Multy,Divy : word);
  431.  
  432.       begin
  433.          _graphresult:=grOk;
  434.          if not isgraphmode then
  435.            begin
  436.               _graphresult:=grnoinitgraph;
  437.               exit;
  438.            end;
  439.          aktmultx:=Multx;
  440.          aktdivx:=Divx;
  441.          aktmulty:=Multy;
  442.          aktdivy:=Divy;
  443.       end;
  444.  
  445.